;;; -*- Mode:LISP; Package:FILE-SYSTEM; Readtable:ZL; Base:10 -*-
;;;; Basic Structures

(DEFVAR LOCAL-FILE-SYSTEM-AREA (MAKE-AREA :NAME 'LOCAL-FILE-SYSTEM-AREA :VOLATILITY 2)
  "All of the internal structures made by the file system are consed in this area.")

(DEFSTRUCT (DISK-CONFIGURATION (:TYPE :NAMED-ARRAY)
                               (:CONC-NAME DC-)
                               (:ALTERANT NIL)
                               (:MAKE-ARRAY (:AREA LOCAL-FILE-SYSTEM-AREA))
                               (:DEFAULT-POINTER DISK-CONFIGURATION))
  VERSION                                       ;The version of the format on disk
  PARTITION-SIZE
  PUT-BASE                                      ;Relative address of the page usage table
  PUT-SIZE
  ROOT-DIRECTORY                                ;The root directory.
  )

(DEFSTRUCT (DIRECTORY (:TYPE :NAMED-ARRAY)
                      :CONC-NAME
                      (:ALTERANT NIL)
                      (:MAKE-ARRAY (:AREA LOCAL-FILE-SYSTEM-AREA)))
  NAME                                          ;The name of the directory
  LOCK                                          ;The lock associated with the directory
  MAP                                           ;The map of the directory.
  FILES                                         ;The files specified in the map.
  )

(DEFSTRUCT (BASIC-FILE (:TYPE :NAMED-ARRAY)
                       (:CONC-NAME FILE-)
                       (:CONSTRUCTOR NIL)
                       (:ALTERANT NIL))
  NAME                                          ;A string.
  LOCK                                          ;A contention lock.
  MAP                                           ;The map of the data.
  FILES                                         ;Used only if the file is a directory.
  TYPE                                          ;A string.
  VERSION                                       ;A number (16b).
  )

(DEFSTRUCT (FILE (:TYPE :NAMED-ARRAY)
                 (:INCLUDE BASIC-FILE)
                 :CONC-NAME
                 (:MAKE-ARRAY (:AREA LOCAL-FILE-SYSTEM-AREA)))
  DEFAULT-BYTE-SIZE
  OVERWRITE-FILE                                ;Links overwriting/overwritten files.
  AUTHOR-INTERNAL                               ;A string
  CREATION-DATE-INTERNAL                        ;A number (32 bits)
  DIRECTORY                                     ;Mommy.
  OPEN-COUNT                                    ;The number of times this file is open
                                                ;-1 if open for overwrite.
  ATTRIBUTES                                    ;A 16-bit word of common properties
  PLIST                                         ;Arbitrary properties.
  GENERATION-NUMBER
  )

(DEFSTRUCT (LINK (:TYPE :NAMED-ARRAY)
                 (:INCLUDE BASIC-FILE)
                 :CONC-NAME
                 (:ALTERANT NIL)
                 (:MAKE-ARRAY (:AREA LOCAL-FILE-SYSTEM-AREA)))
  TO-STRING                                     ;The string linked to, ie "AI: DLA; FOO >"
  )

;;;; Property Bit Definitions

(DEFVAR ATTRIBUTES (MAKE-ARRAY 16.))

(DEFMACRO DEFINE-ATTRIBUTES (&BODY NUMBERS-AND-NAMES)
  `(PROGN 'COMPILE
          . ,(LOOP FOR (NUMBER NAME) ON NUMBERS-AND-NAMES BY #'CDDR
                   NCONCING `((DEFPROP ,NAME ,(1+ (* NUMBER 64.)) ATTRIBUTE)
                              (ASET ',NAME ATTRIBUTES ,NUMBER)))))

(DEFINE-ATTRIBUTES
  0  :DONT-DELETE                               ;File cannot be deleted if on.
  1  :CLOSED                                    ;File is still being written if off.
  2  :DELETED                                   ;File is deleted but still open somewhere.
  3  :DUMPED                                    ;File has been dumped
  4  :DONT-REAP                                 ;Dont reap this file (not used internally)
  5  :CHARACTERS                                ;The file is a CHARACTERS file.
  6  :DIRECTORY                                 ;The file is a subdirectory.

; 10 :QFASLP
; 11 :LISP                                      ;Obsolete
; 12 :TEXT                                      ;Obsolete
; 13 :MAY-BE-REAPED                             ;This bit is used by reaping programs.
                                                ;If it is on, the file is liable to be
                                                ;reaped.  Also, a reaping program may
                                                ;turn it on as a warning that it is liable
                                                ;to be reaped the next time around.
  14 :HEADER-BLOCK
  )

(DEFSUBST FILE-ATTRIBUTE (FILE INDICATOR)
  (LDB-TEST (GET INDICATOR 'ATTRIBUTE) (FILE-ATTRIBUTES FILE)))

(defsetf file-attribute set-file-attribute)

(DEFUN SET-FILE-ATTRIBUTE (FILE INDICATOR VAL)
  (SETF (FILE-ATTRIBUTES FILE)
        (DPB (IF VAL 1 0) (GET INDICATOR 'ATTRIBUTE) (FILE-ATTRIBUTES FILE)))
  (NOT (NULL VAL)))

;;; Syntax for attributes.

(DEFSUBST FILE-CLOSED? (FILE)
  (FILE-ATTRIBUTE FILE :CLOSED))

(DEFSUBST FILE-DELETED? (FILE)
  (FILE-ATTRIBUTE FILE :DELETED))

(DEFSUBST DIRECTORY? (FILE)
  (FILE-ATTRIBUTE FILE :DIRECTORY))

(DEFSUBST ROOT-DIRECTORY? (FILE)
  (NULL (FILE-DIRECTORY FILE)))

(DEFSUBST FILE-NPAGES (FILE)
  (MAP-NPAGES (FILE-MAP FILE)))


;;;; Printers

(DEFSELECT FILE-NSI
  (:PRINT-SELF (FILE STREAM IGNORE IGNORE)
    (SI:PRINTING-RANDOM-OBJECT (FILE STREAM :NO-POINTER)
      (COND ((DIRECTORY? FILE)
             (FORMAT STREAM "LMFS-Directory~{ ~A~}" (DIRECTORY-FULL-NAME FILE)))
            (T
             (FORMAT STREAM "LMFS-File ~S"
                     (LM-NAMESTRING NIL NIL
                                    (DIRECTORY-FULL-NAME (FILE-DIRECTORY FILE))
                                    (FILE-NAME FILE)
                                    (FILE-TYPE FILE)
                                    (FILE-VERSION FILE))))))))

(DEFSELECT DIRECTORY-NSI
  (:PRINT-SELF (DIRECTORY STREAM IGNORE IGNORE)
    (SI:PRINTING-RANDOM-OBJECT (DIRECTORY STREAM :TYPEP :NO-POINTER)
      (PRIN1 (DIRECTORY-NAME DIRECTORY) STREAM))))

(DEFUN DIRECTORY-FULL-NAME (DIRECTORY)
  (AND (NOT (ROOT-DIRECTORY? DIRECTORY))
       (APPEND (DIRECTORY-FULL-NAME (FILE-DIRECTORY DIRECTORY))
               (LIST (DIRECTORY-NAME DIRECTORY)))))

(DEFSELECT MAP-NSI
  (:PRINT-SELF (MAP STREAM IGNORE IGNORE)
    (SI:PRINTING-RANDOM-OBJECT (MAP STREAM :TYPEP)
      (FORMAT STREAM "~D block~:P" (MAP-NBLOCKS MAP))))
  (:DESCRIBE (MAP) (DESCRIBE-MAP MAP)))

(DEFPROP FILE      FILE-NSI      NAMED-STRUCTURE-INVOKE)
(DEFPROP LINK      FILE-NSI      NAMED-STRUCTURE-INVOKE)
(DEFPROP DIRECTORY DIRECTORY-NSI NAMED-STRUCTURE-INVOKE)
(DEFPROP MAP       MAP-NSI       NAMED-STRUCTURE-INVOKE)

;;; Randomness.

(DEFUN LMFS-KEYWORD-OPTION (OPTIONS KEYWORD DEFAULT)
  (COND ((NULL OPTIONS)
         DEFAULT)
        ((EQ KEYWORD (CAR OPTIONS))
         (CADR OPTIONS))
        (T
         (LMFS-KEYWORD-OPTION (CDDR OPTIONS) KEYWORD DEFAULT))))

;;;; Locking Macros

(DEFMACRO LOCKING (LOCK &BODY BODY)
  "Execute BODY with LOCK locked."
  (LET ((LOCK-CELL (GENSYM)))
    `(LET ((,LOCK-CELL (LOCF ,LOCK)))
       (UNWIND-PROTECT
         (PROGN (PROCESS-LOCK ,LOCK-CELL) . ,BODY)
         (%STORE-CONDITIONAL ,LOCK-CELL CURRENT-PROCESS NIL)))))

(DEFMACRO LOCKING-RECURSIVELY (LOCK &BODY BODY)
  "Execute BODY with LOCK locked; don't die if already locked."
  (LET ((LOCK-CELL (GENSYM))
        (LOCK-OWNED (GENSYM)))
    `(LET* ((,LOCK-CELL (LOCF ,LOCK))
            (,LOCK-OWNED (EQ (CAR ,LOCK-CELL) CURRENT-PROCESS)))
       (UNWIND-PROTECT
         (PROGN (IF (NOT ,LOCK-OWNED)
                    (PROCESS-LOCK ,LOCK-CELL))
                . ,BODY)
         (IF (NOT ,LOCK-OWNED)                  ;unlock it only if you locked it.
             (%STORE-CONDITIONAL ,LOCK-CELL CURRENT-PROCESS NIL))))))

(DEFMACRO REQUIRE-LOCK (LOCK)
  (LET ((ERSTR (FORMAT NIL "~S should be locked here but is not."
                       (IF (ATOM LOCK) LOCK (CAR LOCK)))))
    `(IF (NOT (EQ ,LOCK CURRENT-PROCESS))
         (FERROR NIL ,ERSTR))))

(DEFMACRO MODIFYING-DIRECTORY (DIRECTORY &BODY BODY)
  "Lock DIRECTORY, execute BODY, and then mark DIRECTORY as modified."
  (LET ((LOCK-CELL (GENSYM)))
    `(LET ((,LOCK-CELL (LOCF (DIRECTORY-LOCK ,DIRECTORY))))
       (UNWIND-PROTECT
         (PROGN (PROCESS-LOCK ,LOCK-CELL) . ,BODY)
         (PROGN (SETF (FILE-CLOSED? DIRECTORY) NIL)
                (%STORE-CONDITIONAL ,LOCK-CELL CURRENT-PROCESS NIL))))))

(DEFMACRO OPEN-INPUT-FILE ((FILE PATHNAME) &BODY BODY)
  `(LET ((,FILE NIL))
     (UNWIND-PROTECT
       (PROGN
         (SETQ ,FILE (LOOKUP-FILE
                       (PATHNAME-RAW-DIRECTORY ,PATHNAME)
                       (PATHNAME-RAW-NAME ,PATHNAME)
                       (PATHNAME-RAW-TYPE ,PATHNAME)
                       (PATHNAME-RAW-VERSION ,PATHNAME)
                       :ERROR NIL T))
         . ,BODY)
       (WHEN ,FILE
         (LMFS-CLOSE-FILE ,FILE)))))

(DEFMACRO OPEN-INPUT-FILE-OR-DIRECTORY ((FILE PATHNAME) &BODY BODY)
  `(LET ((,FILE NIL))
     (UNWIND-PROTECT
       (PROGN
         (SETQ ,FILE (LOOKUP-FILE
                       (PATHNAME-RAW-DIRECTORY ,PATHNAME)
                       (PATHNAME-RAW-NAME ,PATHNAME)
                       (PATHNAME-RAW-TYPE ,PATHNAME)
                       (PATHNAME-RAW-VERSION ,PATHNAME)
                       :ERROR NIL))
         . ,BODY)
       (WHEN ,FILE
         (LMFS-CLOSE-FILE ,FILE)))))

(DEFCONST LM-VERSION 5
  "Disk format version we will create now if we initialize a partition.")
;Version 4 differs from version 3 in having the
;root directory look like all other directories.
;Version 5 has :HEADER-BLOCK attribute and in-place directory update

(DEFUN INSTALL-NEW-LM-VERSION ()
  (SETF (DC-VERSION) LM-VERSION))

(DEFCONST LM-MINIMUM-VERSION 3
  "Lowest format version we can handle.")

(DEFVAR LM-UNIT 0)                              ;See SET-LM-BAND
(DEFVAR LM-PARTITION "FILE")
(DEFVAR LM-PARTITION-POSSIBILITIES '((0 "DFIL") (0 "FILE") (4 "FILE")))
(DEFVAR LM-PARTITION-BASE)                      ;The address of the partition.

;; ***** This should be replaced by a device scheme.  *****
(DEFVAR DISK-CONFIGURATION)
(DEFVAR DISK-CONFIGURATION-RQB)
(DEFVAR DISK-CONFIGURATION-BUFFER)
(DEFVAR DISK-CONFIGURATION-BUFFER-POINTER)
(DEFVAR DISK-CONFIGURATION-LOCK NIL)

(DEFVAR PUT-LOCK NIL)
(DEFVAR PUT-SCANNING-INDEX 0)
(DEFVAR PUT-RQB)                ;The page usage table is indirected into this.
(DEFVAR PAGE-USAGE-TABLE)       ;The actual table.

;; The first entry in the page usage table tells whether the table is consistent
;; with the rest of the system.  If it is not, this only reflects the fact that
;; some pages are lost...
(DEFCONST PUT-CONSISTENT 1)
(DEFCONST PUT-INCONSISTENT 2)

;; The remaining entries describe all the remaining pages in the file (not counting
;; the configuration page, which is always used).
(DEFCONST PUT-FREE 0)                           ;Page is up for grabs.
(DEFCONST PUT-RESERVED 1)                       ;Page is allocated but (likely) deletable.
(DEFCONST PUT-USED 2)                           ;Page is allocated in core and on disk.
(DEFCONST PUT-UNUSABLE 3)                       ;Page should not be referenced ever.

(DEFVAR PAGE-SIZE-IN-BITS (* PAGE-SIZE 32.))

;; This is also in MTDEFS
(REMPROP 'QUOTIENT-CEILING 'SOURCE-FILE-NAME)
(DEFSUBST QUOTIENT-CEILING (Y X) (CEILING Y X))

;; Get a buffer of the correct byte size
(DEFUN GET-RQB-ARRAY (RQB BYTE-SIZE &AUX TYPE)
  (COND ((= BYTE-SIZE 16.) (RQB-BUFFER RQB))
        ((= BYTE-SIZE 8) (RQB-8-BIT-BUFFER RQB))
        ((SETQ TYPE (CDR (ASSQ BYTE-SIZE '((4 . ART-4B) (2 . ART-2B) (1 . ART-1B)))))
         (MAKE-ARRAY (FLOOR (* (RQB-NPAGES RQB) PAGE-SIZE-IN-BITS) BYTE-SIZE)
                     :AREA LOCAL-FILE-SYSTEM-AREA
                     :TYPE TYPE
                     :DISPLACED-TO RQB
                     ;; This is a system bug.  Don't try to figure it out.
                     :DISPLACED-INDEX-OFFSET (* (%P-CONTENTS-OFFSET (RQB-BUFFER RQB) 3)
                                                 (FLOOR 16. BYTE-SIZE))))
        (T (FERROR NIL "~D is an invalid byte size." BYTE-SIZE))))

;; These are the only interface to the disk in the file system, with the exception
;; of FIND-DISK-PARTITION and UPDATE-PARTITION-COMMENT.
;; The unit is always LM-UNIT, nd the address is relative to
;; the current partition (LM-PARTITION).

(DEFUN LM-DISK-WRITE (RQB ADDR &OPTIONAL (NPAGES (RQB-NPAGES RQB)))
; (COND ((EQ RQB PUT-RQB) (FORMAT T "~%>>Writing the page usage table"))
;       ((EQ RQB DISK-CONFIGURATION-RQB) (FORMAT T "~%>>Writing configuration"))
;       (WITHIN-FILE-SYSTEM (FORMAT T "~%>>Writing an internal structure"))
;       (T (FORMAT T "~%>>Writing a file block")))
  (COND ((< ADDR (DC-PARTITION-SIZE))
         (si:disk-write-n-pages rqb lm-unit (+ addr lm-partition-base) npages))
        (T (FERROR NIL "Disk Write out of range."))))

(DEFUN LM-DISK-READ (RQB ADDR &OPTIONAL (NPAGES (RQB-NPAGES RQB)))
  (COND ((< ADDR (DC-PARTITION-SIZE))
         (si:disk-read-n-pages rqb lm-unit (+ addr lm-partition-base) npages))
        (T (FERROR NIL "Disk Read out of range."))))


;;; Use this to write out new maps.

(DEFMACRO-DISPLACE WITH-MAP-STREAM-OUT ((STREAM) &BODY BODY)
  "A variant of WITH-OPEN-STREAM, it returns a new map."
  `(LET ((.FILE-ABORTED-FLAG. :ABORT)
         (,STREAM NIL))
     (UNWIND-PROTECT
       (PROGN (SETQ ,STREAM (MAKE-MAP-STREAM-OUT))
              ,@BODY
              (SETQ .FILE-ABORTED-FLAG. NIL))
       (IF (AND (NOT (NULL ,STREAM))
                (NOT (ERRORP ,STREAM)))
           (SEND ,STREAM :CLOSE .FILE-ABORTED-FLAG.)))
     (AND (NULL .FILE-ABORTED-FLAG.)
          (SEND ,STREAM :MAP))))

(DEFMACRO-DISPLACE WITH-MAP-STREAM-IN ((STREAM . ARGS) &BODY BODY)
  "A variant of WITH-OPEN-STREAM."
  `(LET ((.FILE-ABORTED-FLAG. :ABORT)
         (,STREAM NIL))
     (UNWIND-PROTECT
       (PROG1 (PROGN (SETQ ,STREAM (MAKE-MAP-STREAM-IN . ,ARGS))
                     . ,BODY)
              (SETQ .FILE-ABORTED-FLAG. NIL))
       (IF (AND (NOT (NULL ,STREAM))
                (NOT (ERRORP ,STREAM)))
           (SEND ,STREAM :CLOSE .FILE-ABORTED-FLAG.)))))

;; Directory information on the disk is stored in packed format.  The
;; following functions allow the file system to read and write fixnums
;; and bignums in such a packed format.

;(DEFUN GET-BYTES (STREAM NBYTES)
;  (LOOP WITH V = 0 AND I = 0
;       AS C = (SEND STREAM :TYI)
;       WHEN (NULL C) RETURN NIL
;       DO (SETQ V (+ (* V 256.) C)
;                I (1+ I))
;       WHEN ( I NBYTES) RETURN V))
;
;(DEFUN PUT-BYTES (STREAM NBYTES VALUE)
;  (LOOP FOR PPSS = (+ (* (1- NBYTES) 512.) 8) THEN (- PPSS 512.)
;       DO (SEND STREAM :TYO (LDB PPSS VALUE))
;       UNTIL (= PPSS 8))
;  VALUE)

;; These macros do not use ONCE-ONLY because it loses in the simple case of NBYTES = 1.

(DEFMACRO GET-BYTES (STREAM NBYTES)
  (LOOP FOR I FROM (1- NBYTES) DOWNTO 0
        AS X = `(SEND ,STREAM :TYI)
        WHEN (PLUSP I) DO (SETQ X `(* ,X ,(^ 256. I)))
        COLLECT X INTO FORMS
        FINALLY (IF (= NBYTES 1)
                    (SETQ FORMS (CAR FORMS))
                  (SETQ FORMS (CONS '+ FORMS)))
                (RETURN FORMS)))

(DEFMACRO PUT-BYTES (STREAM NBYTES VALUE)
  `(PROGN . ,(LOOP FOR PPSS FROM (+ (* (1- NBYTES) #o1000) #o10) DOWNTO #o0010 BY #o1000
                   COLLECTING `(SEND ,STREAM :TYO (LDB ,PPSS ,VALUE)))))

(DEFUN PUT-STRING (STRING STREAM)
  (SEND STREAM :TYO (ARRAY-ACTIVE-LENGTH STRING))
  (SEND STREAM :STRING-OUT STRING))

(DEFUN GET-STRING (STREAM)
  (LET* ((LEN (SEND STREAM :TYI))
         (ARR (MAKE-ARRAY LEN :TYPE 'ART-STRING)))
    (SEND STREAM :STRING-IN NIL ARR 0 LEN)
    ARR))


(DEFVAR *NON-WRITEABLE-PROPERTIES* '(%TRUENAME-INTERNAL %HEADER-INTERNAL))

(DEFUN WRITE-PROPERTY-LIST (STREAM PLIST)
  (DO ((L PLIST (CDDR L))
       (X 0))
      ((NULL L)
       (PUT-BYTES STREAM 1 X))
    (OR (MEMQ (CAR L) *NON-WRITEABLE-PROPERTIES*)
        (INCF X)))
  (DO ((L PLIST (CDDR L))
       (PROP))
      ((NULL L))
    (WHEN (NOT (MEMQ (CAR L) *NON-WRITEABLE-PROPERTIES*))
      (PUT-STRING (GET-PNAME (CAR L)) STREAM)
      (COND ((NULL (SETQ PROP (CADR L)))
             (SEND STREAM :TYO 0))
            ((EQ PROP T)
             (SEND STREAM :TYO 1))
            ((SYMBOLP PROP)
             (COND ((keywordp prop)
                    (SEND STREAM :TYO 2)
                    (PUT-STRING (GET-PNAME PROP) STREAM))
                   (T (SEND STREAM :TYO 3)
                      ;; Use this odd order for ease in interning later.
                      (PUT-STRING (GET-PNAME PROP) STREAM)
                      (PUT-STRING (PACKAGE-NAME (SYMBOL-PACKAGE PROP)) STREAM))))
            ((INTEGERP PROP)
             (SEND STREAM :TYO 4)
             (PUT-BYTES STREAM 3 PROP))
            ((STRINGP PROP)
             (SEND STREAM :TYO 5)
             (PUT-STRING PROP STREAM))
            ((CONSP PROP)
             (SEND STREAM :TYO 6)
             (LET ((*PACKAGE* SI:PKG-USER-PACKAGE)
                   (*READTABLE* si:INITIAL-READTABLE)
                   (*PRINT-BASE* 10.)
                   (*NOPOINT T)
                   (*PRINT-RADIX* NIL)
                   (SI:PRINT-READABLY T))
               (PRIN1 PROP STREAM)))
            ((TYPEP PROP 'PATHNAME)
             (SEND STREAM :TYO 7)
             (LET ((PACKAGE SI:PKG-USER-PACKAGE)
                   (READTABLE SI:INITIAL-READTABLE)
                   (BASE 10.)
                   (*NOPOINT T)
                   (SI:PRINT-READABLY T))
               ;; These are the arguments to MAKE-FASLOAD-PATHNAME.
               (SEND STREAM :TYO #/()
               (PRIN1-THEN-SPACE (SEND (PATHNAME-HOST PROP) :NAME-AS-FILE-COMPUTER) STREAM)
               (PRIN1-THEN-SPACE (PATHNAME-DEVICE PROP) STREAM)
               (PRIN1-THEN-SPACE (PATHNAME-DIRECTORY PROP) STREAM)
               (PRIN1-THEN-SPACE (PATHNAME-NAME PROP) STREAM)
               (PRIN1-THEN-SPACE (PATHNAME-TYPE PROP) STREAM)
               (PRIN1 (PATHNAME-VERSION PROP) STREAM)
               (SEND STREAM :TYO #/))))
            (T (FERROR NIL "I don't know how to write ~S as a property." PROP))))))


(DEFUN READ-PROPERTY-LIST (STREAM &AUX LIST (PAK SI:PKG-KEYWORD-PACKAGE))
  (SETQ LIST (MAKE-LIST (* (SEND STREAM :TYI) 2)))
  (DO ((L LIST (CDDR L)))
      ((NULL L))
    (RPLACA L (INTERN (GET-STRING STREAM) PAK))
    (CASE (SEND STREAM :TYI)
      (0)
      (1 (SETF (CADR L) T))
      (2 (SETF (CADR L) (INTERN (GET-STRING STREAM) PAK)))
      (3 (SETF (CADR L) (INTERN (GET-STRING STREAM)
                                (PKG-FIND-PACKAGE (GET-STRING STREAM) :ASK))))
      (4 (SETF (CADR L) (GET-BYTES STREAM 3)))
      (5 (SETF (CADR L) (GET-STRING STREAM)))
      (6 (SETF (CADR L)
               (LET ((*READ-BASE* 10.)
                     (*PACKAGE* SI:PKG-USER-PACKAGE)
                     (*READTABLE* SI:INITIAL-READTABLE))
                   ;; This can lose pretty badly with #<'s, etc.  -- DLA
                   (CLI:READ STREAM))))
      (7 (LET* ((*READ-BASE* 10.)
                (*PACKAGE* SI:PKG-USER-PACKAGE)
                (*READTABLE* SI:INITIAL-READTABLE)
                (FORM (CLI:READ STREAM))
                (DEFAULT-CONS-AREA WORKING-STORAGE-AREA))       ;<-*
           (SETF (CADR L)
                 (IF (= (LENGTH FORM) 6)
                     (APPLY #'FS:MAKE-FASLOAD-PATHNAME FORM)
                   (EVAL FORM)))))              ;Obsolete form for pathnames to be written.
      (OTHERWISE (FERROR NIL "Invalid Plist property designator."))))
  LIST)

;; Functions for creating and manipulating MAPs.

;;; the default leader length used to be 2, but I cannot find anything
;;; in local file that uses the second slot.  I'm going to use another
;;; slot for the map's owner that will be stored into if the map belongs
;;; to a directory and the :SAVE-DIRECTORY-MAPS debug mode is enabled.
;;; -dg 3/4/86

(defconst *map-leader-length* 3)

(DEFSUBST MAP-NBLOCKS (MAP)
  (ARRAY-LEADER MAP 0))

(defsubst map-owner (map)
  (array-leader map 2))

(defsetf map-owner (map) (owner)
  `(store-array-leader ,owner ,map 2))

(DEFSUBST MAP-BLOCK-LOCATION (MAP INDEX)
  (AREF MAP INDEX 0))

(DEFSUBST MAP-BLOCK-SIZE (MAP INDEX)
  (AREF MAP INDEX 1))

(DEFUN MAP-CREATE (&OPTIONAL (NBLOCKS 32.) INPUTP &AUX MAP)
  (SETQ MAP (MAKE-ARRAY (LIST-IN-AREA LOCAL-FILE-SYSTEM-AREA NBLOCKS 2)
                        :LEADER-LENGTH *map-leader-length*
                        :NAMED-STRUCTURE-SYMBOL 'MAP))
  (SETF (MAP-NBLOCKS MAP) (IF INPUTP NBLOCKS 0))
  MAP)

;; Returns the number of pages used (as opposed to the number of blocks) in the map.
(DEFUN MAP-NPAGES (MAP)
  (LOOP WITH NBLOCKS = (MAP-NBLOCKS MAP)
        FOR I FROM 0 BELOW NBLOCKS
        SUMMING (CEILING (MAP-BLOCK-SIZE MAP I) PAGE-SIZE-IN-BITS)))

(DEFUN MAP-NPAGES-AVAILABLE (MAP)
  (DO ((N (ARRAY-DIMENSION MAP 0))
       (J 0 (1+ J))
       (TOTAL 0)
       (SIZE))
      ((OR (= J N)
           (NULL (SETQ SIZE (MAP-BLOCK-SIZE MAP J))))
       TOTAL)
    (INCF TOTAL (CEILING SIZE PAGE-SIZE-IN-BITS))))

;; This is used during output, when a block is added onto the end of a file.
(DEFUN MAP-APPEND-BLOCK (MAP LOCATION SIZE &AUX (NBLOCKS (MAP-NBLOCKS MAP)))
  (AND (= NBLOCKS (ARRAY-DIMENSION MAP 0))
       (ARRAY-GROW MAP (+ NBLOCKS 32.) 2))
  (WITHOUT-INTERRUPTS
    (SETF (MAP-NBLOCKS MAP) (1+ NBLOCKS))
    (SETF (MAP-BLOCK-LOCATION MAP NBLOCKS) LOCATION)
    (SETF (MAP-BLOCK-SIZE MAP NBLOCKS) SIZE)))

;; Returns the length of the area mapped in bits.
(DEFUN MAP-LENGTH (MAP)
  (LOOP WITH NBLOCKS = (MAP-NBLOCKS MAP)
        FOR I FROM 0 BELOW NBLOCKS
        SUMMING (MAP-BLOCK-SIZE MAP I)))

(DEFUN MAP-READ (STREAM)
  (LOOP WITH NBLOCKS = (GET-BYTES STREAM 2)
        WITH MAP = (MAP-CREATE NBLOCKS T)
        FOR I FROM 0 BELOW NBLOCKS
        DOING (SETF (MAP-BLOCK-LOCATION MAP I) (GET-BYTES STREAM 3))
              (SETF (MAP-BLOCK-SIZE MAP I) (GET-BYTES STREAM 3))
        FINALLY (RETURN MAP)))

(DEFUN MAP-WRITE (STREAM MAP)
  (LET ((NBLOCKS (MAP-NBLOCKS MAP)))
    (PUT-BYTES STREAM 2 NBLOCKS)
    (DOTIMES (I NBLOCKS)
      (MAP-WRITE-1-BLOCK STREAM
                         (MAP-BLOCK-LOCATION MAP I)
                         (MAP-BLOCK-SIZE MAP I))))
  MAP)

(DEFUN EXTENDED-MAP-READ (STREAM)
  (LET ((MAP (MAP-READ STREAM)))
    (SETF (MAP-NBLOCKS MAP) (GET-BYTES STREAM 2))
    MAP))

(DEFUN EXTENDED-MAP-WRITE (STREAM MAP)
  (LET ((NBLOCKS (DO ((N (ARRAY-DIMENSION MAP 0))
                      (J 0 (1+ J)))
                     ((OR (= J N) (NOT (MAP-BLOCK-SIZE MAP J)))
                      J))))
    (PUT-BYTES STREAM 2 NBLOCKS)
    (DOTIMES (I NBLOCKS)
      (MAP-WRITE-1-BLOCK STREAM
                         (MAP-BLOCK-LOCATION MAP I)
                         (MAP-BLOCK-SIZE MAP I)))
    (PUT-BYTES STREAM 2 (MAP-NBLOCKS MAP)))
  MAP)


(DEFUN MAP-WRITE-1-BLOCK (STREAM LOCATION SIZE)
  (PUT-BYTES STREAM 3 LOCATION)
  (PUT-BYTES STREAM 3 SIZE))

(DEFUN DESCRIBE-MAP (MAP &OPTIONAL (STREAM STANDARD-OUTPUT))
  (FORMAT STREAM "~&~S maps out the following blocks:~@
~2@TIndex~3@TLocation~7@TSize~3@TStatus~%" MAP)
  (LET ((NBITS 0))
    (DOTIMES (I (MAP-NBLOCKS MAP))
      (FORMAT STREAM "~6O: ~10O ~10O   ~[Free~;Reserved~;Used~;Bad~]~%"
              I (MAP-BLOCK-LOCATION MAP I) (MAP-BLOCK-SIZE MAP I)
              (AREF PAGE-USAGE-TABLE (MAP-BLOCK-LOCATION MAP I)))
      (INCF NBITS (MAP-BLOCK-SIZE MAP I)))
    (FORMAT STREAM "~%Total of ~D block~:P, ~D bit~:P.~%"
            (MAP-NBLOCKS MAP)
            NBITS)))

(DEFUN FILE-DATA-LENGTH (FILE)
  (MAP-LENGTH (FILE-MAP FILE)))

(DEFUN FILE-NPAGES (FILE)
  (MAP-NPAGES (FILE-MAP FILE)))

(DEFUN FILE-TRUENAME (FILE)
  ;; If at all possible, make the host name be a normal network host name, since these
  ;; names are transportable among machines, whereas "LM" is not.
  (OR (GETF (FILE-PLIST FILE) '%TRUENAME-INTERNAL)
      (SETF (GETF (FILE-PLIST FILE) '%TRUENAME-INTERNAL)
            (MAKE-PATHNAME :HOST (IF SI:LOCAL-HOST (SEND SI:LOCAL-HOST :NAME-AS-FILE-COMPUTER) "LM")
                           :DEVICE "DSK"
                           :DIRECTORY (OR (DIRECTORY-FULL-NAME (FILE-DIRECTORY FILE))
                                          :ROOT)
                           :NAME (FILE-NAME FILE)
                           :TYPE (IF (EQUAL (FILE-TYPE FILE) "")
                                     :UNSPECIFIC
                                   (FILE-TYPE FILE))
                           :VERSION (FILE-VERSION FILE)))))

;; Error handler interface.

(DEFMACRO IDENTIFY-FILE-OPERATION (OPERATION &BODY BODY)
  `(LET ((*CURRENT-FILE-OPERATION* (OR *CURRENT-FILE-OPERATION* ,OPERATION)))
     . ,BODY))

;; Wrap this around things which want to do things the simple way.
;; If ERROR-P is non-NIL and an error occurs, the error object is returned from this form
(DEFMACRO HANDLING-ERRORS (ERROR-P &BODY BODY)
  `(CATCH 'LM-TRAP-ERRORS
     (LET ((LM-TRAP-ERRORS (NOT ,ERROR-P)))
       (FILE-OPERATION-RETRY
         . ,BODY))))

;; This is bound to T if one is inside LM-TRAP-ERROR, in which case control
;; is thrown to LM-TRAP-ERROR
(DEFVAR LM-TRAP-ERRORS NIL)

(DEFVAR *CURRENT-FILE-OPERATION* NIL)
(DEFVAR *CURRENT-OPERATION-PATHNAME* NIL)

(DEFPROP LM-SIGNAL-ERROR T :ERROR-REPORTER)
(DEFUN LM-SIGNAL-ERROR (SYMBOL &OPTIONAL SOURCE PROCEEDABLE &REST MAKE-CONDITION-ARGS)
  (OR SOURCE
      ;; SELF IS PROBABLY NEVER THE PATHNAME
      ;; SINCE SOMEBODY CHANGED FILE-HOST PATHNAMES
      ;; TO USE THE "ACCESS" ABSTRACTION.
      ;; 5-Feb-87 18:29:45 -GJC
      (AND (OR (TYPEP SELF 'PATHNAME)
               (TYPEP SELF 'SI:FILE-STREAM-MIXIN))
           (SETQ SOURCE SELF))
      (SETQ SOURCE *CURRENT-OPERATION-PATHNAME*))
  (AND SOURCE (NOT (TYPEP SOURCE 'PATHNAME))
       (SETQ SOURCE (SEND SOURCE :PATHNAME)))
  (LET ((ERROR
          (APPLY #'MAKE-CONDITION
                 (OR (GET SYMBOL 'ERROR-SIGNALER) SYMBOL)
                 (LET ((STRING (GET SYMBOL 'ERROR-STRING)))
                   (IF SOURCE
                       (STRING-APPEND STRING " for "
                                      (LET ((S (SEND SOURCE :STRING-FOR-PRINTING)))
                                        (COND ((STRING-SEARCH "~" S)
                                               (WITH-OUTPUT-TO-STRING (SO)
                                                 (WITH-INPUT-FROM-STRING (SI S)
                                                   (DO ((C))
                                                       ((NOT (SETQ C (SEND SI :TYI))))
                                                     (IF (= #\~ C) (SEND SO :TYO C))
                                                     (SEND SO :TYO C)))))
                                              ('ELSE
                                               S))))
                     STRING))
                 SOURCE MAKE-CONDITION-ARGS)))
       (IF LM-TRAP-ERRORS
           (THROW 'LM-TRAP-ERRORS ERROR))
       (SIGNAL ERROR
               :PROCEED-TYPES
               (COND ((CONSP PROCEEDABLE) PROCEEDABLE)
                     (PROCEEDABLE '(:RETRY-FILE-OPERATION))))))

;; Use this when an error occurs in file lookup.
(DEFPROP LM-LOOKUP-ERROR T :ERROR-REPORTER)
(DEFUN LM-LOOKUP-ERROR (SYMBOL DIR NAM TYP VER &OPTIONAL (OPERATION *CURRENT-FILE-OPERATION*))
  (LM-SIGNAL-ERROR SYMBOL
                   (MAKE-PATHNAME :HOST "LM" :DEVICE "DSK"
                                  :DIRECTORY
                                  (COND ((STRINGP DIR) DIR)
                                        ((CONSP DIR) DIR)
                                        (T
                                         (DIRECTORY-NAME DIR)))
                                  :NAME NAM :TYPE TYP :VERSION VER)
                   NIL
                   OPERATION))

;; This is to aid in debugging.  It basically provides a warning at compile time
;; if you haven't defined an error.
(DEFUN LM-ERROR-SYMBOL-CHECK (FORM)
  (LET ((X (SECOND FORM)))
    (AND (EQ (CAR-SAFE X) 'QUOTE)
         (PROGN
           (WHEN (NOT (GET (CADR X) 'ERROR-STRING))
             (COMPILER:BARF (CADR X) "is not a defined error symbol" 'COMPILER:WARN))
           (OR (GET (CADR X) 'ERROR-SIGNALER)
               (GET (CADR X) 'EH:MAKE-CONDITION-FUNCTION)
             (COMPILER:BARF (CADR X) "is not a defined signal name" 'COMPILER:WARN))))
    FORM))

(COMPILER:ADD-OPTIMIZER LM-SIGNAL-ERROR LM-ERROR-SYMBOL-CHECK)
(COMPILER:ADD-OPTIMIZER LM-LOOKUP-ERROR LM-ERROR-SYMBOL-CHECK)
(COMPILER:ADD-OPTIMIZER LM-RENAME-ERROR LM-ERROR-SYMBOL-CHECK)

;; Error Definitions
(DEFMACRO DEFINE-ERRORS (&REST SYMBOLS-AND-STRINGS)
  `(PROGN 'COMPILE
          . ,(LOOP FOR (SYMBOL STRING) ON SYMBOLS-AND-STRINGS BY #'CDDR
                   COLLECTING `(DEFPROP ,SYMBOL ,STRING ERROR-STRING))))

(DEFINE-ERRORS
;; Error signalers in SYS:IO;OPEN
  RENAME-TO-EXISTING-FILE       "Attempt to rename to an existing file"
  RENAME-ACROSS-DIRECTORIES     "Attempt to rename across directories"
  FILE-NOT-FOUND                "File not found"
  FILE-ALREADY-EXISTS           "File already exists"
  DIRECTORY-NOT-FOUND           "Directory not found"
  INVALID-BYTE-SIZE             "Illegal byte size"
  NO-MORE-ROOM                  "Disk full"
  NO-FILE-SYSTEM                "File system not mounted"
  DIRECTORY-NOT-EMPTY           "Non-empty directories cannot be deleted"
  DONT-DELETE-FLAG-SET          "File has DONT-DELETE bit set"
  UNIMPLEMENTED-OPTION          "Unimplemented OPEN option"
  FILE-LOCKED                   "File is locked"
  UNKNOWN-OPERATION             "Unknown operation"

;; Error signalers defined below.
  UNDELETE-UNCLOSED-FILE        "Cannot undelete unclosed file"
  OPEN-DELETED-FILE             "File is deleted"
  OPEN-DELETED-DIRECTORY        "Directory is deleted"
  OPEN-OUTPUT-FILE              "File is open for output"
  OPEN-UNFINISHED-DIRECTORY     "Directory still being created"
  FILE-IS-SUBDIRECTORY          "File is a subdirectory"
  UNSETTABLE-PROPERTY           "Unsettable property"
  INVALID-PROPERTY-NAME         "Bad property"
  VERSION-TOO-LARGE             "Version must be smaller than 65536"
  INVALID-DIRECTORY-NAME        "Invalid name given for a directory"
  RENAME-DIRECTORY-INVALID-TYPE "Invalid new type or version for renaming a subdirectory."
  LINKS-NOT-SUPPORTED           "Links not supported"
  BAD-TYPE-FOR-SUBDIRECTORY     "Invalid type for subdirectory"
  SUPERSEDE-DIRECTORY           "Superseding a directory"
  TOP-LEVEL-FILE                "No non-directory files in root"

  ;; also defined in OPEN, experimental.
  INVALID-WILDCARD              "Wildcard that got through pathname parsing but file system didn't like it."
  WRONG-KIND-OF-FILE            "Wrong kind of file for this operation"
  ACCESS-ERROR                  "operation denied by access control"
  INCORRECT-ACCESS-TO-FILE      "operation to file denied by access control"
  INCORRECT-ACCESS-TO-DIRECTORY "operation to directory denied by access control"
  )

(DEFPROP UNDELETE-UNCLOSED-FILE FILE-LOCKED ERROR-SIGNALER)

(DEFSIGNAL OPEN-DELETED-FILE FILE-OPERATION-FAILURE (PATHNAME OPERATION)
           "Opening a file that is deleted.")

(DEFSIGNAL OPEN-DELETED-DIRECTORY FILE-LOOKUP-ERROR (PATHNAME OPERATION)
           "Containing directory is deleted.")

(DEFPROP OPEN-OUTPUT-FILE FILE-OPEN-FOR-OUTPUT ERROR-SIGNALER)

(DEFSIGNAL OPEN-UNFINISHED-DIRECTORY FILE-LOOKUP-ERROR (PATHNAME OPERATION)
  "Containing directory is still being created.")

(DEFSIGNAL FILE-IS-SUBDIRECTORY
           (FILE-OPERATION-FAILURE WRONG-KIND-OF-FILE INVALID-OPERATION-FOR-DIRECTORY)
           (PATHNAME OPERATION)
  "Attempt to open a file which is a directory.")

(DEFSIGNAL UNSETTABLE-PROPERTY CHANGE-PROPERTY-FAILURE (PATHNAME PROPERTY)
           "PROPERTY isn't one of the properties this file system allows users to set.")

(DEFSIGNAL VERSION-TOO-LARGE
           (FILE-OPERATION-FAILURE INVALID-PATHNAME-SYNTAX VERSION-TOO-LARGE)
           (PATHNAME OPERATION)
  "Version larger that 65536.")

(DEFSIGNAL INVALID-DIRECTORY-NAME
           (FILE-OPERATION-FAILURE INVALID-PATHNAME-SYNTAX INVALID-DIRECTORY-NAME)
           (PATHNAME OPERATION)
  "")

(DEFSIGNAL RENAME-DIRECTORY-INVALID-TYPE
           (RENAME-FAILURE RENAME-DIRECTORY-INVALID-TYPE)
           (PATHNAME NEW-PATHNAME)
  "")

(DEFSIGNAL LINKS-NOT-SUPPORTED
           (FILE-OPERATION-FAILURE CREATION-FAILURE CREATE-LINK-FAILURE
                                   LINKS-NOT-SUPPORTED)
           (PATHNAME OPERATION)
  "Links are not supported in this file system.")

(DEFSIGNAL BAD-TYPE-FOR-SUBDIRECTORY
           (FILE-OPERATION-FAILURE CREATION-FAILURE CREATE-DIRECTORY-FAILURE
                                   BAD-TYPE-FOR-SUBDIRECTORY)
           (PATHNAME OPERATION)
  "")

(DEFSIGNAL SUPERSEDE-DIRECTORY
           (FILE-OPERATION-FAILURE CREATION-FAILURE TOP-LEVEL-FILE)
           (PATHNAME OPERATION)
  "Superseding a file which is a subdirectory.")

(DEFSIGNAL TOP-LEVEL-FILE
           (FILE-OPERATION-FAILURE CREATION-FAILURE TOP-LEVEL-FILE)
           (PATHNAME OPERATION)
  "Attempt to create a file not a directory in the root directory.")

;; ALLOCATE-DISK-BLOCK returns the base and size of a block which has pages
;; pre-set to PUT-RESERVED.
;; {VERIFY, CHANGE, SET}-{BLOCK, MAP}-DISK-SPACE.  They should all be called
;; inside the special form USING-PUT.  SET-... should be used minimally.
;; WRITE-PUT (&optional force-p) may be called any time inside a USING-PUT
;; form to force the put to be written onto the disk.  If FORCE-P is nil, and
;; the PUT hasn't been modified in core, this is a no-op.  (WRITE-PUT) is implicit
;; when exitting a USING-PUT.  The USING-PUT special form may be enterred recursively,
;; and in fact usually is.

;; USE-{MAP,BLOCK}-DISK-SPACE??

;; This variable is T if the put has been modified in core and not written to the disk.
(DEFVAR PUT-MODIFIED NIL)

;; This array contains four numbers:  The number of pages in the PUT which
;; have the index as their status.
(DEFVAR PUT-USAGE-ARRAY (MAKE-ARRAY 4 :TYPE 'ART-32B))

;; This is the minimum number of free pages that must be available in order
;; to write files.  Note that internal structures may still be written.
(DEFVAR PUT-MINIMUM-FREE-PAGES 50.)

;; This is bound by LM-WRITE-DIRECTORY to T.  This tells ALLOCATE-DISK-BLOCK
;; that it is OK to go below PUT-MINIMUM-FREE-PAGES.
(DEFVAR WRITING-INTERNAL-STRUCTURES NIL)

(DEFVAR STANDARD-BLOCK-SIZE 20.)

(DEFUN ALLOCATE-DISK-BLOCK (&OPTIONAL (REQUESTED-NPAGES STANDARD-BLOCK-SIZE)
                            &AUX RNP (AVAILABLE 0) FREE-INDEX FREE-NPAGES
                            (PART-SIZE (DC-PARTITION-SIZE)))
  (DO-NAMED ALLOCATE-DISK-BLOCK () (NIL)
    (LOCKING-RECURSIVELY PUT-LOCK
      (COND ((OR WRITING-INTERNAL-STRUCTURES
                 (PLUSP (SETQ AVAILABLE (- (AREF PUT-USAGE-ARRAY PUT-FREE)
                                           PUT-MINIMUM-FREE-PAGES))))
             (SETQ RNP (IF WRITING-INTERNAL-STRUCTURES
                           REQUESTED-NPAGES
                         (MIN REQUESTED-NPAGES AVAILABLE)))
             (SETQ FREE-INDEX
                   (OR (%STRING-SEARCH-CHAR PUT-FREE PAGE-USAGE-TABLE
                                            PUT-SCANNING-INDEX PART-SIZE)
                       (%STRING-SEARCH-CHAR PUT-FREE PAGE-USAGE-TABLE
                                            1 PUT-SCANNING-INDEX)
                       (FERROR NIL "Ran out of disk space on a directory write")))
             (DO ((I FREE-INDEX (1+ I))
                  (P 0 (1+ P)))
                 (NIL)
               (COND ((OR ( P RNP)
                          ( I PART-SIZE)
                          ( (AREF PAGE-USAGE-TABLE I) PUT-FREE))
                      (SETQ PUT-SCANNING-INDEX I)
                      (DECF (AREF PUT-USAGE-ARRAY PUT-FREE) P)
                      (INCF (AREF PUT-USAGE-ARRAY PUT-RESERVED) P)
                      (SETQ FREE-NPAGES P)
                      (RETURN-FROM ALLOCATE-DISK-BLOCK (VALUES FREE-INDEX FREE-NPAGES)))
                     (T (ASET PUT-RESERVED PAGE-USAGE-TABLE I)))))))
    ;; If we get here, the disk is full.  Leave the PUT unlocked so people
    ;; can delete files, and signal a proceedable error.
    (LM-SIGNAL-ERROR 'NO-MORE-ROOM NIL T *CURRENT-FILE-OPERATION*)))

(DEFUN WRITE-PUT (&OPTIONAL FORCE-P)
  (REQUIRE-LOCK PUT-LOCK)
  (COND ((OR PUT-MODIFIED FORCE-P)
         (LM-DISK-WRITE PUT-RQB (DC-PUT-BASE))
         (SETQ PUT-MODIFIED NIL))))

(DEFMACRO USING-PUT (&BODY BODY)
  (LET ((LOCK-OWNED (GENSYM)))
    `(LET ((,LOCK-OWNED (EQ PUT-LOCK CURRENT-PROCESS))
           OLD-STATE)
       (UNWIND-PROTECT
         (PROGN
           (COND ((NOT ,LOCK-OWNED)
                  (PROCESS-LOCK (LOCF PUT-LOCK))
                  (IF (NOT (NULL PUT-MODIFIED))
                      (FERROR NIL "PUT evidently modified while unlocked"))
                  (SETQ OLD-STATE (AREF PAGE-USAGE-TABLE 0))
                  (ASET PUT-INCONSISTENT PAGE-USAGE-TABLE 0)))
           . ,BODY)
         (COND ((NOT ,LOCK-OWNED)
                (ASET OLD-STATE PAGE-USAGE-TABLE 0)
                (WRITE-PUT)
                (PROCESS-UNLOCK (LOCF PUT-LOCK))))))))

(defun maint-reserve-disk-surface-in-file-partition (physical-cylinder head &optional (new-status put-unusable))
  "CYL and HEAD are physical, such as SDU prints on WHY after crash.
Remember, the SDU prints cylinders and heads in DECIMAL"
  (let* ((unit lm-unit)
         (partition-base lm-partition-base)
         (logical-cylinder (- physical-cylinder (si:get-cylinder-offset-for-unit unit)))  ;**verify this is right
                                ;for unit 0 ***
         (SECTORS-PER-TRACK (AREF si:DISK-SECTORS-PER-TRACK-ARRAY UNIT))
         (HEADS-PER-CYLINDER (AREF si:DISK-HEADS-PER-CYLINDER-ARRAY UNIT))
         (physical-block (+ (* logical-cylinder heads-per-cylinder sectors-per-track)
                            (* head sectors-per-track)))
         (partition-block (- physical-block partition-base)))
    (cond ((or (< partition-block 0)
               (>= partition-block (array-length page-usage-table)))
           (ferror "That physical block is not within the file partition")))
    (using-put
      (dotimes (c sectors-per-track)
        (maint-change-block-disk-space (+ partition-block c) new-status)))
    ))

(DEFUN MAINT-CHANGE-BLOCK-DISK-SPACE (LOC NEW-STATUS)
  (REQUIRE-LOCK PUT-LOCK)
  (SETQ PUT-MODIFIED T)
  (let ((old-status (aref page-usage-table loc)))
    (format t "~%changing usage status for block ~o from ~s to ~s" loc old-status new-status)
    (DECF (AREF PUT-USAGE-ARRAY OLD-STATUS) 1)
    (INCF (AREF PUT-USAGE-ARRAY NEW-STATUS) 1)
    (ASET NEW-STATUS PAGE-USAGE-TABLE loc)))

(DEFUN CHANGE-BLOCK-DISK-SPACE (LOC NPAGES OLD-STATUS NEW-STATUS &AUX LIM)
  (REQUIRE-LOCK PUT-LOCK)
  (SETQ LIM (+ LOC NPAGES))
  (AND (PLUSP NPAGES)
       (NOT (AND (= OLD-STATUS PUT-RESERVED) (= NEW-STATUS PUT-FREE)))
       (SETQ PUT-MODIFIED T))
  (DO ((I LOC (1+ I)))
      (( I LIM)
       (DECF (AREF PUT-USAGE-ARRAY OLD-STATUS) NPAGES)
       (INCF (AREF PUT-USAGE-ARRAY NEW-STATUS) NPAGES)
       T)
      (cond ((not (= (AREF PAGE-USAGE-TABLE I) OLD-STATUS))
             (format t "Unexpected disk space status in CHANGE-MAP-DISK-SPACE")
             (aset (max new-status old-status) page-usage-table i))
            (t
             (ASET NEW-STATUS PAGE-USAGE-TABLE I)))))

(DEFUN CHANGE-MAP-DISK-SPACE (MAP OLD-STATUS NEW-STATUS
                              &AUX NBLOCKS LIM LOC COUNT (NPAGES 0))
  (REQUIRE-LOCK PUT-LOCK)
  (SETQ NBLOCKS (MAP-NBLOCKS MAP))
  (AND (PLUSP NBLOCKS)
       (NOT (AND (= OLD-STATUS PUT-RESERVED) (= NEW-STATUS PUT-FREE)))
       (SETQ PUT-MODIFIED T))
  (DO ((MAP-INDEX 0 (1+ MAP-INDEX)))
      (( MAP-INDEX NBLOCKS)
       (DECF (AREF PUT-USAGE-ARRAY OLD-STATUS) NPAGES)
       (INCF (AREF PUT-USAGE-ARRAY NEW-STATUS) NPAGES)
       T)
    (SETQ LOC (MAP-BLOCK-LOCATION MAP MAP-INDEX)
          COUNT (CEILING (MAP-BLOCK-SIZE MAP MAP-INDEX) PAGE-SIZE-IN-BITS)
          LIM (+ LOC COUNT))
    (DO ((I LOC (1+ I)))
        (( I LIM) (INCF NPAGES COUNT))
      (cond ((not (= (AREF PAGE-USAGE-TABLE I) OLD-STATUS))
             (format t "Unexpected disk space status in CHANGE-MAP-DISK-SPACE")
             (aset (max new-status old-status) page-usage-table i))
            (t
             (ASET NEW-STATUS PAGE-USAGE-TABLE I))))))

(DEFUN SET-MAP-DISK-SPACE (MAP NEW-STATUS)
  (REQUIRE-LOCK PUT-LOCK)
  (WHEN (> (MAP-NBLOCKS MAP) 0)
    (SETQ PUT-MODIFIED T)
    (DOTIMES (MAP-INDEX (MAP-NBLOCKS MAP))
      (LET ((COUNT (CEILING (MAP-BLOCK-SIZE MAP MAP-INDEX) PAGE-SIZE-IN-BITS))
            (LOC (MAP-BLOCK-LOCATION MAP MAP-INDEX)))
        (DOTIMES (I COUNT)
          (DECF (AREF PUT-USAGE-ARRAY (AREF PAGE-USAGE-TABLE (+ LOC I))))
          (INCF (AREF PUT-USAGE-ARRAY NEW-STATUS))
          (ASET NEW-STATUS PAGE-USAGE-TABLE (+ LOC I)))))))

(DEFUN DETERMINE-MAP-DISK-SPACE-STATUS (MAP)
  (REQUIRE-LOCK PUT-LOCK)
  (LET ((STATUS NIL))
    (DOTIMES (MAP-INDEX (MAP-NBLOCKS MAP))
      (LET ((COUNT (CEILING (MAP-BLOCK-SIZE MAP MAP-INDEX) PAGE-SIZE-IN-BITS))
            (LOC (MAP-BLOCK-LOCATION MAP MAP-INDEX)))
        (DOTIMES (I COUNT)
          (COND ((NULL STATUS)
                 (SETQ STATUS (AREF PAGE-USAGE-TABLE (+ LOC I))))
                ((NOT (= STATUS (AREF PAGE-USAGE-TABLE (+ LOC I))))
                 (FERROR NIL "Inconsistent status in DETERMINE-MAP-DISK-SPACE-STATUS"))))))
    STATUS))

;; Binding this variable to non-NIL causes auto creation of directories.
;; This is used internally to create directories, but may be bound by things
;; such as magtape restoration programs.
(DEFVAR LM-AUTOMATICALLY-CREATE-DIRECTORIES NIL)

;; This is a variable with all file streams open since boot time.
;; The :OPEN-STREAMS message to a LOCAL-LISPM-HOST returns COPYLIST of this.
(DEFVAR LM-FILE-STREAMS-LIST NIL)

(DEFVAR LM-FILE-STREAMS-LIST NIL)

;;; debuggung stuff - started by dg 3/4/86

(defconst *lmfs-valid-debug-modes* '(:check-directory-maps))

(defconst *lmfs-active-debug-modes* ()
  "This should be a list of active debug modes, or NIL for normal operation.")


;; [HEADER-ID][VERSION][ID-STRING][CDATE][SELF][FLAG][S0-MAP][S1-MAP]
;; 0          28       32         72     76    80    84

;; in version 1, the Sn-MAP's are regular maps.
;; in version 2, the Sn-MAP's are extended maps.
;; in version 3, the hight bits of the FLAG are a generation counter for
;; files created in the directory and the directory entries are extended
;; to include this number.

(DEFVAR NEW-HEADER-FORMAT-VERSION 2)
(DEFVAR NEW-HEADER-ID (STRING-APPEND "_THIS_" "IS_A_DIRECTORY_" "HEADER_"))
(DEFVAR NEW-HEADER-VERSION-OFFSET (LENGTH NEW-HEADER-ID))
(DEFVAR NEW-HEADER-ID-STRING-OFFSET (+ NEW-HEADER-VERSION-OFFSET 4))
(DEFVAR NEW-HEADER-CDATE-OFFSET (+ NEW-HEADER-ID-STRING-OFFSET 40))
(DEFVAR NEW-HEADER-SELF-OFFSET (+ NEW-HEADER-CDATE-OFFSET 4))
(DEFVAR NEW-HEADER-FLAG-OFFSET (+ NEW-HEADER-SELF-OFFSET 4))
(DEFVAR NEW-HEADER-S0-MAP-OFFSET (+ NEW-HEADER-FLAG-OFFSET 4))
(DEFVAR NEW-HEADER-MAX-MAP-BLOCKS (FLOOR (- (FLOOR (- 1024. NEW-HEADER-S0-MAP-OFFSET) 2) 2)
                                         6.))

(DEFUN STRING-GET-32B (ST OFFSET)
  (DPB (AREF ST (+ OFFSET 3))
       (BYTE 8. 24.)
       (DPB (AREF ST (+ OFFSET 2))
            (BYTE 8. 16.)
            (DPB (AREF ST (+ OFFSET 1))
                 (BYTE 8 8)
                 (AREF ST OFFSET)))))

(DEFUN STRING-PUT-32B (ST OFFSET VALUE)
  (SETF (AREF ST OFFSET) (LDB (BYTE 8. 0) VALUE))
  (SETF (AREF ST (+ OFFSET 1)) (LDB (BYTE 8. 8.) VALUE))
  (SETF (AREF ST (+ OFFSET 2)) (LDB (BYTE 8. 16.) VALUE))
  (SETF (AREF ST (+ OFFSET 3)) (LDB (BYTE 8. 24.) VALUE))
  VALUE)

(DEFSTRUCT (DIRHEADER :CONC-NAME :NAMED)
  ID-STRING
  FLAG
  S0-MAP
  S1-MAP)

(DEFMACRO DIRHEADER-FLAG-BIT (H)
  `(LDB ,(BYTE 1 0) (DIRHEADER-FLAG ,H)))

(DEFMACRO DIRHEADER-FLAG-GENERATION-COUNT (H)
  `(LDB ,(BYTE 31 1) (DIRHEADER-FLAG ,H)))
